perm filename MATEVV.SAI[1,BGB]1 blob
sn#102644 filedate 1974-06-17 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 BEGIN "TEST"
C00004 00003 α VERTEX LOCI
C00006 00004 SUBR ECOEF (ITG E)
C00007 00005 SUBR ECROSS(ITG I,J)
C00009 00006 RECURSIVE PROCEDURE QSORT (INTEGER I,J REAL CUT)
C00011 00007 SUBR MKVERTICES
C00012 00008 SUBR MATEVV (INTEGER V1,V2)
C00013 00009 SUBR MKEDGES
C00015 00010 SUBR EECROSS
C00016 00011 SUBR REFACE (ITG F,E)
C00017 00012 SUBR MKWINGS
C00019 00013 OUTSTR("MAKE FACES."&↓)
C00020 00014 α OUTPUT
C00022 00015 α MAIN EXECUTION
C00025 ENDMK
C⊗;
BEGIN "TEST"
REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
REQUIRE "DPYIII[SYS,BGB]" SOURCE_FILE;
SAFE ITG ARRAY DPYBUF[0:3000];
PRELOAD_WITH 0,0,0,1,0,0,0,1,0,0,0,1;SAFE REAL ARRAY LOCOR[-3:8];
α VERTEX NODES;
SAFE REAL ARRAY X,Y,Z[1:100];
SAFE ITG ARRAY VX,VY,PED[1:100];
SAFE REAL ARRAY XYZ[1:3];
α EDGE NODES;
SAFE ITG ARRAY PVT,NVT,EDG,PFACE,NFACE[0:1000];
SAFE ITG ARRAY NCW,PCW,NCCW,PCCW[1:1000];
SAFE REAL ARRAY AA,BB,CC,DD[1:1000];
ITG I,J,K,RRMAX,RMAX;
ITG VCNT,ECNT,FCNT;
ITG COMCNT,EECNT;
α MICRO LISP;
SAFE ITG ARRAY FS[1:2000];ITG FSPTR;
ITG SUBR XWD(ITG A,B); S⊂ HRLZ 1,A;HRR 1,B;⊃;
ITG SUBR CONS(ITG A,B); ⊂ ITG I;I←FSPTR;
FSPTR←FS[I];FS[I]←XWD(A,B);RETURN(I);⊃;
DEFINE CAR(A)="(FS[A] LSH -18)";
DEFINE CDR(A)="(FS[A] LAND '777777)";
α VERTEX LOCI;
PRELOAD_WITH
α PROPERTY LINE;
-745, -465, 331, α 1;
130, -900, 410, α 2;
360, -710, 420, α 3;
1170, 140, 360, α 4;
290, 780, 440, α 5;
100, 870, 450, α 6;
-510, 470, 350, α 7;
-510, 360, 347, α 8;
-540, 210, 344, α 9;
-595, 50, 340, α 10;
-625, -30, 338, α 11;
-690, -305, 332, α 12;
-705, -360, 331, α 13;
α GRID POINTS - NEAR HALF OF BUILDING;
0, 0, 443, α 14 CENTER OF BUILDING;
200, 0, 437, α 15;
400, 0, 435, α 16;
0, 200, 440, α 17;
200, 200, 429, α 18;
400, 200, 410, α 19;
0, -200, 429, α 20;
200, -200, 440, α 21;
400, -200, 442; α 22;
SAFE REAL ARRAY V[1:100,1:3];
SUBR ECOEF (ITG E);
BEGIN "ECOEF"
ITG V1,V2,A,B; REAL C,D;
V1 ← PVT[E];
V2 ← NVT[E];
A ← Y[V1]-Y[V2];
B ← X[V2]-X[V1];
C ← X[V1]*Y[V2] - X[V2]*Y[V1];
D ← SQRT(A*A + B*B);
AA[E] ← A/D;
BB[E] ← B/D;
CC[E] ← C/D;
DD[E] ← D;;
END "ECOEF";
SUBR ECROSS(ITG I,J);
BEGIN "ECROSS"
ITG V1,V2,U1,U2;
REAL D1,D2;
DEFINE PE="0.0001";
DEFINE NE="-0.0001";
IF PVT[I]=0 ∨ PVT[J]=0 THEN RETURN;
V1 ← PVT[I]; V2 ← NVT[I];
U1 ← PVT[J]; U2 ← NVT[J];
IF V1=U1 ∨ V1=U2 ∨ V2=U1 ∨ V2=U2 THEN RETURN;
COMCNT←COMCNT+1;
IF (X[U1] MAX X[U2]) < (X[V1] MIN X[V2]) THEN RETURN;
IF (Y[U1] MAX Y[U2]) < (Y[V1] MIN Y[V2]) THEN RETURN;
IF (X[V1] MAX X[V2]) < (X[U1] MIN X[U2]) THEN RETURN;
IF (Y[V1] MAX Y[V2]) < (Y[U1] MIN Y[U2]) THEN RETURN;
D1 ← AA[I]*X[U1] + BB[I]*Y[U1] + CC[I];
D2 ← AA[I]*X[U2] + BB[I]*Y[U2] + CC[I];
IF (D1≥PE ∧ D2≥PE) ∨ (D1≤NE ∧ D2≤NE) THEN RETURN;
D1 ← AA[J]*X[V1] + BB[J]*Y[V1] + CC[J];
D2 ← AA[J]*X[V2] + BB[J]*Y[V2] + CC[J];
IF (D1≥PE ∧ D2≥PE) ∨ (D1≤NE ∧ D2≤NE) THEN RETURN;
IF DD[J] > DD[I] THEN I↔J;
PVT[I]←NVT[I]←0;
END "ECROSS";
RECURSIVE PROCEDURE QSORT (INTEGER I,J; REAL CUT);
BEGIN "QSORT"
INTEGER L,H;
α BUBBLE SORT THE FEW;
IF (J-I) ≤ 6 THEN ⊂
FOR L←I THRU J-1 DO FOR H←L+1 THRU J DO
IF DD[EDG[L]] < DD[EDG[H]] THEN EDG[L]↔EDG[H]; RETURN;⊃;
α PARTITION SORT THE MANY;
L ← I; H ← J;
WHILE TRUE DO
BEGIN
WHILE L<H ∧ DD[EDG[L]] ≥ CUT DO L←L+1;
WHILE L<H ∧ DD[EDG[H]] < CUT DO H←H-1;
IF L=H THEN ⊂ L←L-1;DONE;⊃;
EDG[L]↔EDG[H];
END;
IF I<L THEN QSORT(I,L, (DD[EDG[I]] + DD[EDG[L]])/2);
IF H<J THEN QSORT(H,J, (DD[EDG[H]] + DD[EDG[J]])/2);
END "QSORT";
SUBR MKVERTICES;
FOR I←1 THRU VCNT DO
BEGIN "MKV"
LABEL L;
FOR I←1 THRU VCNT DO
BEGIN
X[I] ← V[I,1];
Y[I] ← V[I,2];
Z[I] ← V[I,3];
AIVECT(X[I]/2-10,Y[I]/2-10);DPYSST("* "&CVS(I));
END;
END "MKV";
SUBR MATEVV (INTEGER V1,V2);
BEGIN "MATEVV"
ITG I,EL,E;
IF (X[V1]-X[V2])↑2 + (Y[V1]-Y[V2])↑2 > RRMAX THEN RETURN;
IF V2>V1 THEN V1↔V2;
EL ← PED[V1];
WHILE EL≠0 DO ⊂ E←CAR(EL);
IF V1=PVT[E] ∧ V2=NVT[E] THEN RETURN ELSE EL←CDR(EL);⊃;
ECNT ← ECNT+1;
PVT[ECNT] ← V1;
NVT[ECNT] ← V2;
PED[V1] ← CONS(ECNT,PED[V1]);
PED[V2] ← CONS(ECNT,PED[V2]);
END "MATEVV";
SUBR MKEDGES;
BEGIN "MKEDGES"
ECNT ← 0;
RRMAX ← RMAX*RMAX;
α XSORT THE VERTICES;
FOR I←1 THRU VCNT DO EDG[I]←I;
ARRBLT(DD[1],X[1],VCNT);
QSORT(1,VCNT,(X[1]+X[VCNT])/2);
ARRBLT(VX[1],EDG[1],VCNT);
α YSORT THE VERTICES;
FOR I←1 THRU VCNT DO EDG[I]←I;
ARRBLT(DD[1],Y[1],VCNT);
QSORT(1,VCNT,(Y[1]+Y[VCNT])/2);
ARRBLT(VY[1],EDG[1],VCNT);
FOR I←1 THRU VCNT-1 DO
FOR J←I+1 THRU VCNT DO
IF VX[J] - VX[I] < RMAX THEN
MATEVV(VX[I],VX[J]) ELSE DONE;
FOR I←1 THRU VCNT-1 DO
FOR J←I+1 THRU VCNT DO
IF VY[J] - VY[I] < RMAX THEN
MATEVV(VY[I],VY[J]) ELSE DONE;
FOR K←1 THRU ECNT DO ECOEF(K);
END "MKEDGES";
SUBR EECROSS;
BEGIN "EECROSS"
ITG V1,V2,E1,E2,E3,EL1,EL2,EL3;
FOR V1←1 THRU VCNT DO
BEGIN EL1 ← PED[V1]; WHILE EL1≠0 DO
BEGIN E1←CAR(EL1); EL1←CDR(EL1);
IF (V2←PVT[E1])=0 THEN CONTINUE ELSE IF V1=V2 THEN V2←NVT[E1];
EL3 ← PED[V1]; WHILE EL3≠0 DO
BEGIN E3←CAR(EL3);EL3←CDR(EL3);
EL2 ← PED[V2]; WHILE EL2≠0 DO
⊂ E2←CAR(EL2);EL2←CDR(EL2);
IF E2<E3 THEN ECROSS(E2,E3);⊃;
END;END;END;
END "EECROSS";
SUBR REFACE (ITG F,E);
BEGIN ITG E1,E2;
E2←E;
DO BEGIN
E1 ← E2; E2 ← (IF PFACE[E2]=F THEN PCCW[E2] ELSE NCCW[E2]);
IF E1=PCW[E2] THEN PFACE[E2]←F ELSE NFACE[E2]←F;
END UNTIL E2=E;
END;
SUBR MKWINGS;
BEGIN "MKWINGS"
ITG E,EL,I,J,CNT;
ITG V1,V2;
FOR V1←1 THRU VCNT DO
BEGIN "VLOOP"
α GET ALL THE EDGES OF THE VERTEX;
EL ← PED[V1]; I←0; WHILE EL≠0 DO
⊂ E←CAR(EL);EL←CDR(EL); IF PVT[E]≠0 THEN EDG[I←I+1]←E;⊃;CNT ← I;
α COMPUTE AZIMUTH OF EDGE WITH RESPECT TO V1;
FOR I←1 THRU CNT DO
⊂ E←EDG[I]; V2←PVT[E]; IF V2=V1 THEN V2←NVT[E];
DD[I] ← ATAN2(Y[V2]-Y[V1],X[V2]-X[V1]); ⊃;
α SORT THE EDGES INTO THEIR CYCLIC ORDER ABOUT V1;
FOR I←1 THRU CNT-1 DO
FOR J←I+1 THRU CNT DO
IF DD[I]>DD[J] THEN ⊂ DD[I]↔DD[J];EDG[I]↔EDG[J];⊃;
α BOUNDARY CASES;
EDG[0]←EDG[CNT]; EDG[CNT+1]←EDG[1];
α PLACE THE WING POINTERS INTO EDGES;
FOR I←1 THRU CNT DO
IF V1=PVT[E←EDG[I]] THEN
⊂ PCW[E]←EDG[I+1];NCCW[E]←EDG[I-1];⊃ ELSE
⊂ NCW[E]←EDG[I+1];PCCW[E]←EDG[I-1];⊃
END "VLOOP";
OUTSTR("MAKE FACES."&↓);
FCNT←0;
FOR E←1 THRU ECNT DO
IF PVT[E]≠0 THEN
BEGIN
IF PFACE[E]=0 THEN ⊂ PFACE[E]←FCNT←FCNT+1; REFACE(FCNT,E);⊃;
IF NFACE[E]=0 THEN ⊂ NFACE[E]←FCNT←FCNT+1; REFACE(FCNT,E);⊃;
END;
α RE-SERIAL NUMBER THE EDGES;
I←0; FOR E←1 THRU ECNT DO
IF PVT[E]≠0 THEN EDG[E]←I←I+1 ELSE EDG[E]←0;
EECNT←I;
FOR E←1 THRU ECNT DO
IF EDG[E]≠0 THEN
BEGIN
NCW[E] ← EDG[NCW[E]];
PCW[E] ← EDG[PCW[E]];
NCCW[E] ← EDG[NCCW[E]];
PCCW[E] ← EDG[PCCW[E]];
END;
α OUTPUT;
OPEN(1,"DSK",8,0,3,0,0,0);
ENTER(1,"TMP.B3D",0);
WORDOUT(1,0);
WORDOUT(1,FCNT);WORDOUT(1,EECNT);WORDOUT(1,VCNT); α FEV COUNTERS;;
WORDOUT(1,0); WORDOUT(1,0); α PNAME;
ARRYOUT(1,LOCOR[-3],12);
FOR I←1 THRU FCNT DO ⊂ WORDOUT(1,0);WORDOUT(1,0);⊃;
FOR I←1 THRU ECNT DO
IF EDG[I]≠0 THEN
BEGIN
WORDOUT(1,XWD(NFACE[I],PFACE[I]));
WORDOUT(1,XWD( NVT[I], PVT[I]));
WORDOUT(1,XWD( NCW[I], PCW[I]));
WORDOUT(1,XWD( NCCW[I], PCCW[I]));
END;
FOR I←1 THRU VCNT DO
BEGIN
XYZ[1]←X[I];XYZ[2]←Y[I];XYZ[3]←Z[I];
ARRYOUT(1,XYZ[1],3);
END;
RELEASE(1);
OUTSTR(" EOF"&↓);
END "MKWINGS";
α MAIN EXECUTION;
RMAX ← 4000;
VCNT ← 22;
FOR I←1 THRU 1999 DO FS[I]←I+1;FS[2000]←0;FSPTR←1;
DPYSET(DPYBUF);DPYBIG(1);MKVERTICES;DPYOUT(0);
MKEDGES;
EECROSS;
α DISPLAY THE EDGES;
DPYSET(DPYBUF);
FOR K←1 THRU ECNT DO
IF PVT[K]≠0 THEN
⊂ AIVECT(X[PVT[K]]/2,Y[PVT[K]]/2);
AVECT(X[NVT[K]]/2,Y[NVT[K]]/2);⊃;
DPYOUT(1);
MKWINGS;
WHILE TRUE DO INCHRW;
END "TEST";